home *** CD-ROM | disk | FTP | other *** search
/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops ƒ / Struct < prev    next >
Text File  |  1998-05-02  |  26KB  |  1,074 lines
  1. ¥ Standard data structure classes
  2.  
  3. ¥ May  91        Added Longword
  4. ¥ June 91        Reimplemented ordered-col etc. using multiple inheritance
  5. ¥ May  92        Added obj_array
  6. ¥ July 92        Fixed OBJ: ObjHandle to use NPTR: instead of PTR:
  7. ¥                HandleArray now inherits from Obj_array.
  8. ¥ Dec 92        Replaced UGET: in Int and Byte with new classes UINT and UBYTE.
  9.  
  10. cr .( loading Struct...)
  11.  
  12. :class    LONGWORD  super{ object }    ¥ Generic superclass for var, handle etc.
  13.  
  14.     4    bytes    data
  15.  
  16. :m CLEAR:    inline{ 0 obj !}    0 ^base !  ;m
  17. :m GET:        inline{ obj @}        ^base @  ;m
  18. :m PUT:        inline{ obj !}        ^base !  ;m
  19. :m ->:        inline{ @ obj !}    chksame  @  put: self  ;m
  20.  
  21. :m PRINT:    ^base @  .  ;m
  22.  
  23. :m CLASSINIT:    clear: self  ;m
  24.  
  25. ;class
  26.  
  27.  
  28. :class    VAR  super{ longword }
  29.  
  30. :m +:        inline{ obj +!}    ^base +!   ;m
  31. :m -:        inline{ obj -!}    ^base -!   ;m
  32.  
  33. ;class
  34.  
  35.  
  36. :class    INT    super{ object }
  37.  
  38.     2 bytes data
  39.  
  40. :m CLEAR:    inline{ 0 obj w!}    0 ^base w!  ;m
  41. :m GET:        inline{ obj w@x}    ^base w@x  ;m
  42. :m PUT:        inline{ obj w!}        ^base w!  ;m
  43. :m +:        inline{ obj w+!}    ^base w+!  ;m
  44. :m -:        inline{ obj w-!}    ^base w-!  ;m
  45. :m ->:        inline{ w@ obj w!}
  46.         chksame  w@  put: self  ;m
  47.  
  48. :m INT:        ^base w@  makeint  ;m    ¥ return as toolbox int
  49.  
  50. :m PRINT:    ^base w@x  .  ;m
  51.  
  52. :m CLASSINIT:    clear: self  ;m
  53.  
  54. ;class
  55.  
  56. :class  UINT  super{ int }
  57.  
  58. :m GET:    inline{ obj w@}  ^base w@  ;m
  59.  
  60. :m PRINT:    ^base w@  .  ;m
  61.  
  62. ;class
  63.  
  64.  
  65. :class    BYTE    super{ object }
  66.  
  67.     1 bytes data
  68.  
  69. :m CLEAR:    inline{ 0 obj c!}    0 ^base c!  ;m
  70. :m GET:        inline{ obj c@x}    ^base c@x  ;m
  71. :m PUT:        inline{ obj c!}        ^base c!  ;m
  72. :m +:        inline{ ^base c@ + ^base c!}  ;m
  73. :m -:        inline{ negate ^base c@ + ^base c!}  ;m
  74. :m ->:        inline{ c@ obj c!}    chksame  c@  put: self  ;m
  75.  
  76. :m PRINT:    ^base c@x  .  ;m
  77.  
  78. :m CLASSINIT:    clear: self  ;m
  79.  
  80. ;class
  81.  
  82.  
  83. :class  UBYTE  super{ byte }
  84.  
  85. :m GET:        inline{ obj c@}    ^base c@  ;m
  86.  
  87. :m PRINT:    ^base c@  .  ;m
  88.  
  89. ;class
  90.  
  91.  
  92. :class    BOOL    super{ byte }
  93.  
  94. :m PUT:        inline{ 0<> obj c!}        0<>  ^base c!  ;m
  95. :m SET:        inline{ true obj c!}    true  ^base c!  ;m
  96.         ¥ note - CLEAR: is defined in the superclass Byte
  97.  
  98. :m NOT:        inline{ obj c@ not obj c!}    ^base c@ not ^base c!  ;m
  99.  
  100. :m PRINT:    get: self  IF  ." true"  ELSE  ." false"  THEN  ;m
  101.  
  102. ;class
  103.  
  104.  
  105. ¥ Handle class can store handles to relocatable heap blocks.
  106. ¥ It would be nice to store the length too, but this class is used
  107. ¥ for handles in toolbox records so we can't.  Not here at least.
  108.  
  109.     0    value    RELCNT        ¥ For testing - counts release: msgs
  110.                             ¥ to make sure we're releasing everything
  111.  
  112. :class    HANDLE    super{ longword }
  113.  
  114. :m PTR:        ¥ Dereferences handle to get pointer.  Trap if nil.
  115.     inline{ obj @ @}    ^base @ @  ;m
  116.  
  117. :m NPTR:        ¥ Dereferences handle and masks with SAmask so we can
  118.                 ¥ use the pointer numerically.
  119.     ^base @ @ SAmask and  ;m
  120.  
  121. :m RELEASE:        ¥ Deallocates the heap block, if allocated.
  122.     1 ++> relCnt  killH  ;m
  123.  
  124. :m CLEAR:    nilH  ^base !  ;m    ¥ We hope we know what we're doing.
  125.  
  126. :m NIL?:        ¥ ( -- b )
  127.     get: self  nilH =  ;m
  128.  
  129. :m SETSIZE:    ¥ ( size -- }
  130.     setHsz  0= ?error 166  ;m
  131.  
  132. :m SIZE:        ¥ ( -- size )  Gets current size.
  133.     getHSz  ;m
  134.  
  135. :m NEW:        ¥ ( size -- )
  136.     newH  0= ?error 166  ;m
  137.  
  138. :m LOCK:    lok    ;m
  139. :m UNLOCK:    unlok  ;m
  140.  
  141. :m GETSTATE:  ( -- state )    HgetSt  ;m
  142. :m SETSTATE:  ( state -- )    HsetSt  ;m
  143.  
  144. :m LOCKED?:   ( -- b )        HgetSt  $ 80 and  0<>  ;m
  145.  
  146. :m MOVEHI:    MvHHi  drop ( errors don't really matter here )  ;m
  147.  
  148. :m ->:        ¥ ( ^hdl -- )  Copies passed-in handle's heap data to self.
  149.     chkSame  copyH  ?error 167  ;m
  150.  
  151. :m PRINT:
  152.     & $ emit  ^base @  u.h  ;m    ¥ We assume a print: of a handle is more
  153.                                 ¥  useful in hex.
  154.  
  155. :m CLASSINIT:    clear: self  ;m        ¥ Initially nil
  156.  
  157. ;class
  158.  
  159.  
  160. ¥ OBJHANDLE is a handle that points to an object in the heap.
  161.  
  162. :class    OBJHANDLE  super{ handle }
  163.  
  164. :m OBJ:        moveHi: self  lock: self  nptr: self  >obj  ;m
  165.  
  166.     ¥ Note: if we're going to bind to a heap-based object,
  167.     ¥ the handle MUST be locked while we do so - anything
  168.     ¥ may happen before the method returns!!  Thus we make the
  169.     ¥ obj: method do a moveHi and lock.  But remember to unlock
  170.     ¥ the handle eventually!  (Unless you're releasing it, of course.)
  171.  
  172. :m NEWOBJ:  ( #els ) { ^class -- }
  173.         ¥ Usage:  5  ['] someClass  newObj: someHndl
  174.  
  175.     ^class  cl>len  8 +  new: self
  176.     ^class  obj: self  make_obj  unlock: self  ;m
  177.  
  178. :m RELEASEOBJ:
  179.     nil?: self  ?EXIT
  180.     obj: self  release: []  release: super  ;m
  181.  
  182. :m RELEASE:    releaseObj: self  ;m        ¥ Standard destructor name.
  183.  
  184.     ¥ Note: we define both release: and releaseObj: so that in classes
  185.     ¥ HandleArray and HandleList we can distinguish between releasing the
  186.     ¥ current object and releasing the whole lot.  Release: is of course
  187.     ¥ overridden in those two classes to release the entire structure.
  188.  
  189. :m PRINT:
  190.     print: super  4 spaces  ." object: "
  191.     nil?: self
  192.     if    ." (none)"
  193.     else    print: [ obj: self ]  unlock: self
  194.     then   ;m
  195.  
  196. :m DUMP:
  197.     dump: super  cr
  198.     ." object: "
  199.     nil?: self
  200.     if    ." (none)"
  201.     else    dump: [ obj: self ]  unlock: self
  202.     then   ;m
  203.  
  204. ;class
  205.  
  206. :class    PTR     super{ longword }
  207.  
  208. :m RELEASE:        ¥ Deallocates the heap block, if allocated.
  209.     killP  ;m
  210.  
  211. :m NEW:   ( len -- )    newP  0= ?error 121  ;m
  212.  
  213. :m NIL?:   ( -- b )        ^base @  nilP =  ;m
  214.  
  215. :m CLEAR:    nilP  ^base !  ;m        ¥ We hope we know what we're doing.
  216.  
  217. :m CLASSINIT:    clear: self  ;m        ¥ Initially nil
  218.  
  219. ;class
  220.  
  221.  
  222. ¥ DICADDR is a relocatable dictionary address class - use to store
  223. ¥ non-executable dictionary addresses.
  224.  
  225. :class     DICADDR  super{ longword }
  226.  
  227. :m GET:        ^base  @abs    ;m
  228. :m PUT:        ^base  reloc!    ;m
  229.  
  230. :m PRINT:    get: self  .id  ;m
  231.  
  232. :m CLASSINIT:    ['] null  put: self  ;m
  233.  
  234. ;class
  235.  
  236.  
  237. ¥ X-ADDR is an executable dictionary address class.  The only significant
  238. ¥ difference to DicAddr is that there is an Exec: method.
  239. ¥ But if we ever have to separate code and data, having a separate class
  240. ¥ could prove very useful.  An x-addr is the same as a Mops execution token.
  241.  
  242. :class    X-ADDR    super{ object }
  243.  
  244.     4    bytes    data
  245.  
  246. :m EXEC:    inline{ obj ex}    ^base @abs  execute  ;m
  247.  
  248. :m GET:        ^base  @abs    ;m
  249. :m PUT:        ^base  reloc!   ;m
  250.  
  251. :m CLASSINIT:    ['] null  put: self  ;m
  252.  
  253. ;class
  254.  
  255.  
  256. ¥        ============= Arrays ===============
  257.  
  258. : ?#XTS    ¥ ( n1 n2 -- )  Used to check that the right
  259.         ¥ number of stacked cfas is being passed in.
  260.     <>  ?error 171  ;    ¥ "Wrong number of cfas"
  261.  
  262.  
  263. ¥ Class INDEXED-OBJ is the generic superclass for all arrays.  Here we define
  264. ¥ the general indexed methods, which apply regardless of indexed width.
  265.  
  266. :class    INDEXED-OBJ  super{ object }
  267.  
  268. :m ^ELEM:    ^elem  ;m
  269.  
  270. :m LIMIT:    limit  ;m
  271.  
  272. :m WIDTH:    idxbase  6 -  w@  ;m
  273.  
  274. :m IXADDR:    idxbase  ;m
  275.  
  276. :m CLEARX:    ¥ Erases indexed area.
  277.     idxbase  limit  width: self  *  erase  ;m
  278.  
  279. :m CLASSINIT:    clearX: self  ;m
  280.  
  281. ;class
  282.  
  283.  
  284. ¥ ARRAY is the basic 4-byte cell array.
  285.  
  286. :class    ARRAY  super{ indexed-obj }  4 indexed
  287.  
  288. :m AT:  ( index -- n )        inline{ ix @}    ^elem4  @    ;m
  289. :m TO:  ( n index -- )        inline{ ix !}    ^elem4  !    ;m
  290. :m +TO:  ( n index -- )        inline{ ix +!}    ^elem4  +!    ;m
  291. :m -TO:  ( n index -- )        inline{ ix -!}    ^elem4  -!    ;m
  292. :m ^ELEM:  ( idx -- addr )    inline{ ix}    ^elem4    ;m
  293.  
  294. :m FILL:        ¥ ( value -- )  Fills all elements with value.
  295.     idxbase  limit 4*  bounds
  296.     ?do  dup  i !  4 +loop  drop  ;m
  297.  
  298. :m WIDTH:    4  ;m        ¥ Faster than the default in Indexed-obj.
  299.  
  300. :m GETELEM:    ¥ ( addr -- n )  Fetches one element at addr - saves indexing
  301.         ¥        step if addr is known.
  302.     @  ;m
  303.  
  304. ;class
  305.  
  306.  
  307. ¥ X-ARRAY can execute its elements.
  308.  
  309. :class    X-ARRAY  super{ array }
  310.  
  311. :m TO:  ( index -- )    ^elem: super  reloc!  ;m
  312.  
  313. :m EXEC:  ( index -- )
  314.     inline{ ix ex}    ^elem: self  @abs  execute  ;m
  315.  
  316. :m FILL:        ¥ ( xt -- )
  317.     limit nif  drop  exit  then    ¥ Out if no elements
  318.     idxbase  tuck  reloc!    @  fill: super  ;m
  319.  
  320. :m PUT:            ¥ ( xt0 ... xt(N-1) N -- )
  321.     limit  0EXIT                ¥ Out if no elements
  322.     false -> relocChk?            ¥ May get used in instantiating exported objs
  323.     limit ?#xts
  324.     idxbase  dup  limit 1-  4*  +
  325.     do  i reloc!  -4 +loop
  326.     true -> relocChk?  ;m
  327.  
  328. :m ACTIONS:        ¥ A synonym for put:.  A more appropriate name to use in
  329.                 ¥ sub-classes such as dialogs.
  330.     put: self  ;m
  331.  
  332. private
  333.  
  334. :m PrintNxts:    ¥ ( n -- )
  335.     0 ?do  i ^elem: self  @abs  cr .id  loop  ;m
  336.  
  337. public
  338.  
  339. :m PRINT:        limit  printNxts: self  ;m
  340.  
  341. :m CLASSINIT:    ['] null  fill: self  ;m
  342.  
  343. ;class
  344.  
  345.  
  346. ¥ SEQUENCE is a generic superclass for classes which have multiple items which
  347. ¥ frequently need to be looked at in sequence.  At present the main function of
  348. ¥ Sequence is to implement the EACH: method, which makes it very simple to
  349. ¥ deal with each element.  The usage is
  350. ¥
  351. ¥    BEGIN  each: <obj>  WHILE  <do something to the element>  REPEAT
  352. ¥
  353. ¥ Sequence can be multiply inherited with any class which implements the
  354. ¥ FIRST?: and NEXT?: methods.  The actual implementation details are quite
  355. ¥ irrelevant, as long as these methods are supported.
  356.  
  357. ¥ But note that any class using Sequence should not appear in a record, since
  358. ¥ we must late bind to self, so a class pointer must be present.
  359.  
  360. :class    SEQUENCE    super{ object }        general
  361.  
  362. record
  363. {    var    NXT_XT
  364.     var    ^SELF
  365. }
  366.  
  367. :m EACH:        ¥ ( -- (varies) T  |  -- F )
  368.     get: nxt_xt
  369.     NIF                                ¥ First time in:
  370.         first?: [self]  0dup  0EXIT
  371.         self  bind_with next?:        ¥ Late-bind to next?: and cache
  372.         put: nxt_xt  put: ^self        ¥  the xt for the loop
  373.         true                        ¥ Yes, we've got the 1st element
  374.     ELSE                            ¥ Subsequent time in:
  375.         get: ^self  get: nxt_xt  ex-method        ¥ Call next?: method (cached)
  376.         IF  true  ELSE  clear: nxt_xt  false  THEN
  377.     THEN  ;m
  378.  
  379. :m UNEACH:    ¥ Use to terminate an EACH: loop before the end.
  380.     clear: nxt_xt  ;m
  381.  
  382. ;class
  383.  
  384.  
  385. 0    value    LASTSUP
  386. 0    value    LASTSUPADDR
  387.  
  388. : REMOVELASTSUPER  { ^class ¥ infa -- }
  389.     ^class ifa displace  -> infa
  390.     BEGIN  infa @ 0>  NWHILE  infa ^nextivar  -> infa
  391.     REPEAT
  392.     BEGIN
  393.         4 ++> infa
  394.         infa @
  395.     NUNTIL
  396.     4 --> infa
  397.     infa -> lastSupAddr
  398.     infa @  -> lastSup
  399.     0 infa !  ;
  400.             
  401. : RESTORELASTSUPER
  402.     lastSup lastSupAddr !  ;
  403.  
  404.  
  405. (*
  406. OBJ_ARRAY is a generic superclass which makes it easy to generate an array
  407. of objects of a given class.  Just define a new class which multiply
  408. inherits from the given class (or classes) and OBJ_ARRAY (which must come
  409. last).  This will add an indexed section to each object of the new class,
  410. with elements wide enough to contain objects of the original class.  Then
  411. SELECT: "switches in" the selected element to be the "current" element,
  412. and all the normal methods  of the class can then be used.
  413. The implementation is general rather than brilliantly fast.  If switching
  414. between elements is really a performance concern, you could override
  415. SELECT: - especially if you know the element width.  But note, we do
  416. assume the elements are aligned.
  417. *)
  418.  
  419. :class  OBJ_ARRAY  super{ indexed-obj sequence }    32767 indexed
  420.             ¥ The 32767 signals that the real indexed width is to be
  421.             ¥  taken from the other superclass(es).
  422.  
  423. record
  424. {    int  CURRENT  }
  425.  
  426. :m CURRENT:
  427.     get: current  ;m
  428.  
  429. :m SELECT:  { idx ¥ datalen slf -- }
  430.     idx  get: current =  ?EXIT                ¥ out if nothing to do
  431.     width: self  -> datalen   self -> slf                ¥ set up
  432.     slf  get: current  ^elem  datalen  aligned_move        ¥ switch out previous
  433.     idx ^elem                                ¥ note: will give an error if out of range
  434.                                             ¥  - so we do it before we store in current
  435.     slf  datalen  aligned_move                ¥ switch in new
  436.     idx  put: current  ;m
  437.  
  438. :m FIRST?:
  439.     limit NIF  false  EXIT  THEN
  440.     0  select: self  true  ;m
  441.  
  442. :m NEXT?:
  443.     get: current 1+  limit  >=  IF  false  EXIT  THEN
  444.     get: current 1+  select: self  true  ;m
  445.     
  446.  
  447. :m PRINTALL:    ¥ Sends PRINT: to all elements
  448.     get: current
  449.     BEGIN  each: self  WHILE  print: [self]  REPEAT
  450.     select: self  ;m
  451.  
  452. (*
  453. CLASSINIT: needs to initialize all the elements.  Element 0 has been
  454. initialized already, by the time we get classinit: sent here, since we're
  455. the last superclass.  We could select each element and send deep_classinit:,
  456. but it's a bit tricky getting the right class to use.  Instead we'll just
  457. copy element 0 to the other elements, which will usually be good enough.
  458. *)
  459.  
  460. :m CLASSINIT:  { ¥ dln slf -- }
  461.     width: self  -> dln   self -> slf            ¥ set up
  462.     limit  1        ¥ note: elt 0 has had classinit: already!
  463.     ?DO
  464.            slf  i ^elem  dln  aligned_move
  465.     LOOP
  466. ;m
  467.  
  468. ;class
  469.  
  470.  
  471. (* LARGE_OBJ_ARRAY is similar in usage to OBJ_ARRAY, but is faster
  472. if the elements are large (>20 bytes or so).
  473.  
  474. When we select an element, we don't move it, but instead update
  475. an offset to the current element, which we keep in the ivar xdispl.
  476. When we call a method in the selected element, ^base is set to
  477. the element, naturally.  This means that we need a ^class offset
  478. at the start of each element, which we didn't need in obj_array.
  479. So we allocate two extra bytes for each element, and set up all
  480. the ^class offsets at classinit: time.
  481. *)
  482.  
  483. :class  LARGE_OBJ_ARRAY  super{ indexed-obj sequence }    32766 indexed
  484.             ¥ The 32766 signals that the real indexed width is to be
  485.             ¥  taken from the other superclass(es).
  486.  
  487.  
  488. record
  489. {    var  xdispl
  490.     int  CURRENT  }
  491.  
  492. :m CURRENT:
  493.     get: current  ;m
  494.  
  495. :m SELECT:  { idx ¥ datalen slf -- }
  496.     idx  get: current =  ?EXIT            ¥ out if nothing to do
  497.     idx ^elem 2+                        ¥ 2+ to step over ^class offset
  498.     addr: xdispl  displ!
  499.     idx  put: current  ;m
  500.  
  501. :m FIRST?:
  502.     limit NIF  false  EXIT  THEN
  503.     0  select: self  true  ;m
  504.  
  505. :m NEXT?:
  506.     get: current 1+  limit  >=  IF  false  EXIT  THEN
  507.     get: current 1+  select: self  true  ;m
  508.     
  509.  
  510. :m PRINTALL:    ¥ Sends PRINT: to all elements
  511.     get: current
  512.     BEGIN  each: self  WHILE  print: [self]  REPEAT
  513.     select: self  ;m
  514.  
  515. (*
  516. CLASSINIT: needs to initialize all the elements.  The base object has been
  517. set up already, by the time we get classinit: sent here, since we're
  518. the last superclass, but it isn't one of the elements!  So analogously
  519. to what we do in OBJ_ARRAY, we copy the base object to all the elements
  520. (INCLUDING elt zero here!).
  521. *)
  522.  
  523. :m CLASSINIT:  { ¥ dln slf addr ^obj -- }
  524.     ^base 2- wdisplace  -> ^obj
  525.     width: self  -> dln   self -> slf            ¥ set up
  526.     limit  0
  527.     ?DO
  528.            i ^elem  -> addr
  529.            ^obj addr wdispl!
  530.            slf addr 2+ dln  aligned_move
  531.     LOOP
  532. ¥ now we set up the xdispl ivar, so elt 0 is initially selected.
  533.     idxBase 2+  addr: xdispl  displ!
  534. ;m
  535.  
  536. ;class
  537.  
  538.  
  539. ¥ (PHlist) is a superclass for HandleList and PtrList, mainly aimed at
  540. ¥ factoring out common code.  It's really only meant for internal use.
  541.  
  542. :class (PHlist)  super{ sequence }
  543.  
  544. record
  545. {    handle    THELIST
  546.     var        SIZE
  547.     var        POS
  548. }
  549.  
  550. private
  551.  
  552. :m  (SEL):    ¥ ( n -- )  n is offset into theList, NOT an index.
  553.     self @  ptr: theList  get: pos +  !        ¥ switch out previous
  554.     put: pos
  555.     ptr: theList  get: pos  +  @  self !    ¥ switch in new
  556. ;m
  557.  
  558. public
  559.  
  560. :m ADD:  { addMe ¥ whr ^class -- }
  561.     get: size  -> whr
  562.     whr
  563.     NIF    nil?: theList
  564.         IF        80  new: theList        ¥ Give it room to play with
  565.         ELSE    80  setsize: theList
  566.         THEN
  567.     THEN
  568.     whr cell+  dup  setsize: theList  put: size
  569.     whr  (sel): self
  570.     addMe  self !
  571. ;m
  572.  
  573.  
  574. :m REMOVE:  { ¥ whr cnt -- }        ¥ Completely removes the current element.
  575.     ptr: theList  get: pos  +  -> whr
  576.     1cell  -: size  get: size  get: pos  -  -> cnt
  577.     cnt IF  whr cell+  whr  cnt  move  THEN
  578.                     ¥ note: can't use aligned_move since it's a move down,
  579.                     ¥ and overlaps
  580.     get: pos  cell-  0 max  put: pos
  581.     ptr: theList  get: pos  +  @  self !    ¥ switch in new current elt
  582.     get: size  NIF  release: theList  THEN  ;m
  583.  
  584.  
  585. :m SELECT:    ¥ ( n -- )
  586.     4*  0  get: size cell-  within? not  ?error 134
  587.     (sel): self  ;m
  588.  
  589. :m SELECTLAST:
  590.     get: size  cell-  (sel): self  ;m
  591.  
  592. :m CURRENT:    get: pos  4/  ;m
  593.  
  594. :m SIZE:    get: size 4/  ;m
  595.  
  596. ¥ The next two methods are needed by EACH:, but may be called directly as well.
  597. ¥ Note that NEXT?:  ASSUMES that the list is allocated in the heap and that a
  598. ¥ valid element is selected as the current element.  EACH: ensures this,
  599. ¥ since if FIRST?: returns false, NEXT?: is never called.  But if you call
  600. ¥ it directly, make sure this condition holds.
  601.  
  602. :m FIRST?:    ¥ ( -- n T | -- F )
  603.     nil?: theList  IF  false  EXIT  THEN
  604.     0 (sel): self  self @  true  ;m
  605.  
  606. :m NEXT?:  { ¥ nxt -- n T | -- F }
  607.     get: pos  cell+  -> nxt
  608.     nxt  get: size  >= IF  false  EXIT  THEN
  609.     nxt (sel): self  self @  true  ;m
  610.  
  611.  
  612. :m DUMPALL:
  613.     nil?: theList IF  ." (not open)"  EXIT  THEN
  614.     dump: super  cr  ." current: "  current: self  dup .
  615.     cr ." elements: "  cr
  616.     BEGIN  each: [self]  WHILE  dump: [self]  REPEAT
  617.     select: self  ;m
  618.  
  619. :m PRINTALL:
  620.     nil?: theList IF  ." (not open)"  EXIT  THEN
  621.     get: pos
  622.     BEGIN  each: self  WHILE  print: [self]  cr  REPEAT
  623.     (sel): self  ;m
  624.  
  625. ;class
  626.  
  627.  
  628. ¥ HANDLEARRAY and HANDLELIST are for the implementation of collections
  629. ¥ of heap-based objects.  HandleArray has normal array properties, and
  630. ¥ thus a definite length.  HandleList, however, allows the number of
  631. ¥ elements to grow arbitrarily large.  Use HandleList if you need an
  632. ¥ indefinite number of elements, and if indexing isn't so important.
  633. ¥ HandleArray also includes methods to allow the array to be used as a
  634. ¥ stack - needed for FileList.
  635.  
  636. :class    HANDLEARRAY  super{ objHandle  array  obj_array }
  637.  
  638. record
  639. {    int    size  }
  640.  
  641. :m SIZE:        get: size  ;m
  642. :m SETSIZE:        put: size  ;m
  643.  
  644. :m RELEASE:
  645.     get: size  0  ?DO
  646.         i select: self  releaseObj: self
  647.     LOOP  ;m
  648.  
  649. :m PUSH:        ¥ ( hdl -- )
  650.     get: size  limit  >=  ?error 137
  651.     get: size  select: self  1 +: size
  652.     put: super  ;m
  653.  
  654. private
  655. :m (TOP):
  656.     get: size  dup
  657.     IF        1-  select: self
  658.     ELSE    drop  clear: current
  659.     THEN  ;m
  660. public
  661.  
  662. :m TOP:
  663.     get: size  0= ?error 136  (top): self  ;m
  664.  
  665. :m DROP:
  666.     get: size  dup  0= ?error 136
  667.     1-  select: self  releaseObj: self
  668.     1 -: size  (top): self  ;m
  669.  
  670. :m PUSHNEWOBJ:
  671.     0 push: self  newObj: self  ;m
  672.  
  673. :m CLEARX:    nilH  fill: self  ;m
  674.  
  675. :m  CLASSINIT:    clearX: self  clear: self  ;m
  676.  
  677. ;class
  678.  
  679.  
  680. ¥ HANDLELIST allows the implementation of a list of heap-based objects.
  681. ¥ Unlike HANDLEARRAY, the list can be of indefinite length.  We use a heap
  682. ¥ block to store the handles to the objects contiguously, rather than have
  683. ¥ a separate block for each handle and link them together.  This saves on
  684. ¥ memory overhead and reduces the number of memory manager calls.  It also
  685. ¥ reflects the assumption that insertions and deletions into the middle of
  686. ¥ the list will be infrequent, as these could be more inefficient than with
  687. ¥ a linked scheme.  We expect that elements will normally be added to the
  688. ¥ end, and probably not removed at all, or not very often.
  689.  
  690.  
  691. :class  HANDLELIST  super{ objHandle (PHlist) }
  692.  
  693. ¥ FIRST?: and NEXT?:, needed for the EACH: construction, are overridden here
  694. ¥ since if the next element exists we return the object address as well as
  695. ¥ the True.  We also need to unlock the previous objHandle when we step
  696. ¥ to the next one.
  697.  
  698. :m SIZE:    ¥ We're overriding here since objHandle has a size: method
  699.             ¥  which isn't really useful here
  700.     size: super> (PHlist)  ;m
  701.  
  702. :m FIRST?:    ¥ ( -- ^obj T | -- F )
  703.     first?: super  NIF  false  EXIT  THEN
  704.     drop  obj: self  true  ;m
  705.  
  706. :m NEXT?:  { ¥ nxt -- ^obj T | -- F }
  707.     unlock: super
  708.     next?: super  NIF  false  EXIT  THEN
  709.     drop  obj: self  true  ;m
  710.  
  711.  
  712. :m NEWOBJ:    ¥ ( ^class -- )
  713.     nilH  add: super> (PHlist)
  714.     newObj: super  ;m
  715.  
  716. :m REMOVEOBJ:            ¥ Completely removes the current element.
  717.     releaseObj: super  remove: super  ;m
  718.  
  719. :m RELEASE:
  720.     BEGIN  each: self  WHILE  drop  releaseObj: super  REPEAT
  721.     release: theList
  722.     clear: pos  clear: size  ;m
  723.  
  724. :m DUMPALL:
  725.     nil?: theList if  ." (not open)"  EXIT  THEN
  726.     dump: super  cr  ." current: "  get: pos  dup 4/ .
  727.     cr ." elements: "  cr
  728.     BEGIN  each: self  WHILE  dump: []  REPEAT
  729.     (sel): self   ;m
  730.  
  731. :m PRINTALL:
  732.     nil?: theList if  ." (not open)"  EXIT  THEN
  733.     get: pos
  734.     BEGIN  each: self  WHILE  print: []  cr  REPEAT
  735.     (sel): self  ;m
  736.     
  737. ;class
  738.  
  739.  
  740. :class PTRLIST  super{ ptr (PHlist) }
  741.  
  742. ;class
  743.  
  744.  
  745. ¥            ============== Collections ================
  746.  
  747. ¥ Collections are ordered lists with a current size.  We implement them by
  748. ¥ multiply inheriting the generic (COL) class with the array class of the
  749. ¥ appropriate width.  We use a few tricks to avoid late binding to self
  750. ¥ in loops.
  751.  
  752. :class    (COL)  super{ object }
  753.  
  754. record
  755. {    int    SIZE    }            ¥ # elements in list
  756.  
  757. :m SIZE:    ¥ ( -- cursize )  Returns #elements currently in list
  758.      inline{ get: size}  get: size  ;m
  759.  
  760. :m CLEAR:    ¥ Set to list to null
  761.     clear: size   clearx: [self]  ;m
  762.  
  763. :m ADD:        ¥ ( val -- )  add value to end of list
  764.     get: size  limit  >=  ?error 137
  765.     get: size  to: [self]  1 +: size  ;m
  766.  
  767. :m LAST:        ¥ ( -- val )  Returns contents of end of list
  768.     get: size  dup 0=  ?error 136
  769.     1-  at: [self]  ;m
  770.  
  771. :m REMOVE:  { indx ¥ cnt wid addr -- }    ¥ Removes the element at index
  772.     get: size  indx -  1-  -> cnt
  773.     cnt 0<  ?error 136
  774.     width: [self]  -> wid
  775.     indx  ^elem: [self]  -> addr
  776.     1 -: size
  777.     cnt  0exit
  778.     addr wid +  addr  cnt wid *  move  ;m
  779.  
  780. :m INDEXOF:  { val ¥ ^self ^getelem wid addr -- indx T  | -- F }
  781.                 ¥ Finds a value in a collection.
  782.     self  bind_with getelem:  -> ^getelem  -> ^self
  783.     width: [self]  -> wid  idxbase -> addr
  784.     false  get: size  0
  785.     ?do
  786.         addr  ^self ^getelem  ex-method
  787.         val =  if  drop  i  true  leave  then
  788.         wid ++> addr
  789.     loop  ;m
  790.  
  791. :m PRINT:
  792.     get: size  0  ?do  i  at: [self]  cr .  loop  ;m
  793.  
  794. :m DUMP:
  795.     dump: super  ." size: "  get: size .  ;m
  796.  
  797. ;class
  798.  
  799.  
  800. ¥ Ordered-Collection is a collection of 4-byte cells.
  801.  
  802. :class    ORDERED-COL    super{ (col) array }
  803. ;class                        ¥ That's all, folks!!
  804.  
  805.  
  806. ¥ X-COL is a collection of execution tokens.
  807.  
  808. :class    X-COL    super{  (col)  x-array  }
  809.  
  810. :m  REMOVEXT:    ¥ ( xt -- )
  811.     false -> relocChk?  pad reloc!  true -> relocChk?
  812.     pad @  indexof: self  0EXIT
  813.     remove: self  ;m
  814.  
  815. :m  PRINT:
  816.     get: size  printNXts: self  ;m
  817.  
  818. ;class
  819.  
  820.  
  821.  
  822.  
  823. :class    DIC-MARK    super{ object }
  824.  
  825. #threads    array    LINKS
  826. record {    int        CURRENT    }
  827.  
  828. private
  829.  
  830. :m  SETC:  { ¥ addr index -- index }
  831.     0 -> addr  0 -> index
  832.     #threads FOR
  833.         i at: links  dup addr u>
  834.         IF  -> addr  i -> index  ELSE  drop  THEN
  835.     NEXT
  836.     index  put: current  ;m
  837. public
  838.  
  839. :m CURRENT:
  840.     get: current  at: links  ;m
  841.  
  842. :m SET:  { addr -- }
  843.     #threads FOR
  844.         context  i  2 <<  +  displace
  845.         BEGIN    dup addr u>            ¥ We're 32-bit clean around here!
  846.         WHILE    displace
  847.         REPEAT
  848.         i to: links
  849.     NEXT
  850.     setc: self  ;m
  851.  
  852. :m SETTOTOP:    big#  set: self  ;m
  853.  
  854. :m NEXT:  { ¥ lfa -- lfa }
  855.     get: current  at: links
  856.     dup -> lfa  dup  0EXIT
  857.     displace  get: current  to: links
  858.     setc: self  lfa  ;m
  859.  
  860. ;class
  861.  
  862. dic-mark    TheMARK
  863.  
  864.  
  865. ¥         ========== Resource support ===========
  866.  
  867. :class    RESOURCE  super{ handle }
  868.  
  869. record
  870. {    var    RESTYPE
  871.     int    ID
  872. }
  873.  
  874. :m SET:        ¥ ( type id# -- )
  875.     put: ID  put: resType   ;m
  876.  
  877. :m GETNEW:
  878.     get: resType  get: ID  getRes  dup
  879.     NIF                            ¥ Failed - display type and ID
  880.         cr  addr: resType  4  type  2 spaces
  881.         get: ID  .  170 die        ¥ Couldn't find this resource
  882.     THEN
  883.     put: super  ;m
  884.  
  885. :m GETXSTR:  { idx ¥ addr -- addr len }
  886.     getnew: self
  887.     ptr: self  -> addr
  888.     addr w@ 1-  idx min  -> idx
  889.     2 ++> addr
  890.     idx 0 ?DO  addr count +  -> addr  LOOP
  891.     addr count   ;m
  892.  
  893. ;class
  894.  
  895. ¥                ====================================
  896.  
  897. ¥                        SOME UTILITY WORDS
  898.  
  899. ¥                ====================================
  900.  
  901. ¥ Any special run-time initialization can be done conveniently by adding
  902. ¥ the appropriate words to the x-col INIT_ACTIONS.  These words will be
  903. ¥ executed on startup via EXTRA_INITS, right after OBJINIT.
  904.  
  905.     8    x-col    INIT_ACTIONS
  906.  
  907. : X        size: init_actions  0  ?DO  i exec: init_actions  LOOP  ;
  908.  
  909. ' x  -> extra_inits
  910.  
  911.  
  912. : SCREENBITS    ¥ ( -- l t r b )
  913.                 ¥ Gets dimension coordinates of host machine's display.
  914.     $ 904 @ @  116 -        ¥ **** warning - low mem global ref'd
  915.     dup    @ unpack
  916.     rot 4+ @ unpack  ;
  917.  
  918.  
  919. : CHKKEY
  920.     cr     type# 189            ¥ "paused - <space> to continue..."
  921.     cr                        ¥ 01Feb94 DBH  Add cr.  Better for TW.
  922.     (key)  cr  0 -> out  bl =  nif  cr decimal abort  then  ;
  923.  
  924.  
  925. : ?P
  926.     sleepticks  0 -> sleepticks
  927.     ?terminal
  928.     swap -> sleepticks
  929.     NIF  pause  EXIT  THEN        ¥ No key hit - just do default PAUSE
  930.     (key) drop  chkKey  ;
  931.  
  932. : P
  933.     sleepticks  0 -> sleepticks
  934.     ?terminal  drop
  935.     -> sleepticks  ;
  936.  
  937. ' p        -> pause            ¥ This will be improved when Events is loaded
  938. ' ?p    -> ?pause
  939.  
  940.  
  941. : WORDS  { ¥ svbase svcurs n -- }
  942.     setToTop: theMark  0 -> out  0 -> n
  943.     base -> svbase  hex  curs -> svcurs  -curs  cr
  944.     BEGIN
  945.         next: theMark
  946.         ?dup
  947.     WHILE
  948.         1 ++> n
  949.         out 60 >
  950.         if  cr  0 -> out  ?pause  then
  951.         link> dup  6 .r  2 spaces  .id  space
  952.         20  out 20 mod -  spaces
  953.     REPEAT
  954.     svbase -> base
  955.     cr ." No of words: "  n .  cr
  956.     svcurs -> curs  ;
  957.  
  958.  
  959. false    value    ENDTRAV?    ¥ May be set from within a trav handler
  960.                 ¥ to terminate the trav
  961.  
  962. : (TRAV)  { theWord parm -- }
  963.     false -> endTrav?
  964.     BEGIN
  965.         next: theMark
  966.         ?dup  0EXIT
  967.         link>  parm  theWord execute
  968.         endTrav?
  969.     UNTIL  ;
  970.  
  971. : TRAV    ¥ ( xt parm -- )
  972.         ¥ Traverses the dictionary, passing each xt and the parm
  973.         ¥ to the passed-in proc.
  974.  
  975.     setToTop: theMark  (trav)  ;
  976.  
  977. : TRAV-FROM    ¥ ( xt parm addr -- )
  978.             ¥ As for TRAV, but starts from the first word whose lfa is
  979.             ¥ below or at the given address.
  980.  
  981.     set: theMark  (trav)  ;
  982.  
  983.  
  984. ¥                =============== Dump ==================
  985.  
  986. ¥ This used to be in the Util module.  But sometimes the loading of that
  987. ¥ module could cause the address of what we wanted to dump to change.
  988.  
  989.     0    value    DUMPADDR
  990.     0    value    DUMPLEN
  991.  
  992. : U.R
  993.     >r 0 <# #s #>  r> over - spaces  type  ;
  994.  
  995. : dot4    0 <#  # # # #  #>    type  space  ;
  996.  
  997. : D.4    ( addr len -- )  bounds do  i w@  dot4  2 +loop  ;
  998.  
  999. : EMIT.        ¥ ( c -- )
  1000.     127 and  bl 126 within?  nif  drop  & .  then  emit  ;
  1001.  
  1002. : DLN        ¥ ( addr -- )
  1003.     cr  dup  8 u.r  2 spaces
  1004.     dup ( addr )  8 2dup d.4 space  +  8 d.4 space
  1005.     16  bounds DO  i c@ emit.  LOOP  ;
  1006.  
  1007.  
  1008. : ?.N        ¥ ( n1 n2 -- n1 )
  1009.     2dup = if  ." ¥/"  drop  else  1 .r space  then  ;
  1010.  
  1011. : ?.A        ¥ ( n1 n2 -- n1 )
  1012.     2dup = if  drop  & V  emit  else  1 .r  then  ;
  1013.  
  1014. : .HEAD        ¥ ( addr len -- addr' len' )
  1015.     swap  dup -16 and  swap 15 and  cr  10 spaces
  1016.      8 0 DO  i ?.n   i 1+ ?.n  space  2 +LOOP  space
  1017.     16 8 DO  i ?.n   i 1+ ?.n  space  2 +LOOP  space
  1018.     16 0 DO  i ?.a  LOOP   rot +  ;
  1019.  
  1020. :f DUMP  { addr len ¥ svBase svCurs -- }
  1021.     base -> svBase  hex  curs -> svCurs  -curs
  1022.     addr len  .head
  1023.     2dup  -> dumpLen  -> dumpAddr        ¥ Save for DN
  1024.     bounds  DO  i dln  ?pause  16 +LOOP  cr
  1025.     svbase -> base  svCurs -> curs  ;f
  1026.  
  1027. : DN        ¥ Dump next
  1028.     dumpLen ++> dumpAddr  dumpAddr dumpLen dump  ;
  1029.  
  1030. : .W    '  >name 200 dump  ;
  1031.  
  1032.  
  1033. <" String
  1034.  
  1035. ¥ Testing:
  1036.  
  1037. 4 handlearray hh
  1038.  
  1039. key!
  1040. +echo
  1041.  
  1042. :class HAHA super{ object }
  1043. public
  1044. record
  1045. {    var        v1
  1046.     int        i1
  1047.     uint    i2
  1048. }
  1049.  
  1050. :m test:        $ 99  put: v1  $ 88 put: i1  $ 77 put: i2  ;m
  1051. :m print:        print: v1  print: i1  print: i2  cr  ;m
  1052. :m classinit:    1 put: v1  2 put: i1  3 put: i2 ;m
  1053. ;class
  1054.  
  1055. :class VArr super{ haha large_obj_array }
  1056. :m test1:    $ 55 put: v1  $ 44 put: i1  $ 33 put: i2  ;m
  1057. :m test2:    db  test: super  test1: self  ;m
  1058. ;class
  1059.  
  1060. 6 varr OA
  1061.  
  1062. key!
  1063.  
  1064.  
  1065. handleList HL
  1066.  
  1067. key!
  1068.  
  1069. : h1 ." hello"  ;
  1070. : h2 ." hi there!"  ;
  1071.  
  1072. 3 x-array xx
  1073. xts{ h1 h2 h1 } put: xx
  1074.